home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / CGIshell 1.3.2 / Pocket 6.5 / Source / Dictionary.txt < prev    next >
Text File  |  1995-11-11  |  46KB  |  1,914 lines
  1. ; this file is: Dictionary.txt  --  forth words
  2. ; Tue Apr 05, 1988 21:59:10 load files >32K
  3. ; Thu Apr 07, 1988 15:59:46 nested loads
  4. ; Tue Apr 19, 1988 05:05:37 change "?BUTTON"
  5. ; Mon Apr 25, 1988 15:10:19 implement macros
  6. ; Tue Apr 26, 1988 19:49:49 optomizing "BACK"
  7. ; Thu Apr 28, 1988 23:09:23 fix ID.  better CONSTANT,2CONSTANT  add zero
  8. ; Fri Apr 29, 1988 09:43:49 add DLITERAL
  9. ; Sun May 01, 1988 04:24:52 make VARIABLE a macro
  10. ; Thu May 12, 1988 11:41:08 remove (PDO)  add 1- 2- & SP@  use slashFail
  11. ; Sun May 29, 1988 20:16:39 make CREATE shorter
  12. ; Tue May 31, 1988 14:27:25 make +MD a 4 byte macro  remove 2-
  13. ; Tue Jun 07, 1988 11:39:00 add R0@, S0@, RP@  redo STOD
  14. ; Sun Jun 23, 1991 09:33:00 add OPEN
  15. ; Thu Jan 13, 1992 19:05:00 Floating point math (rewrite 13Apr)
  16. ; Sun Feb 02, 1992 00:02:00 fix BACK
  17. ; Wed Apr 01, 1992 00:12:00 change STKCHK
  18. ; Tue Apr 14, 1992 22:48:00 rearrange to bring essentials toward front
  19. ; Sun Apr 19, 1992 23:24:00 split open into 2 parts, add AE: ;AE> ?GESTALT
  20. ; Sat Sep 19, 1992 17:05:00 fix FROLL in decimal places 15-19
  21. ; Fri Jan 22, 1993 19:28:00 fix TYPE
  22. ; Mon Apr 19, 1993 22:58:00 move ?BUTTON and FLITERAL
  23. ; Thu May 06, 1993 23:04:00 fix +LOOP and QUIT
  24. ; Sat May 29, 1993 15:20:00 fix TYPE (again)
  25. ; Tue Jun 01, 1993 23:25:00 add WARM, DEPTH
  26. ; Wed Jun 09, 1993 20:17:00 change IMMEDIATE,PAGE,doLoad,header,dictstart
  27. ; Sun Oct 15, 1995 18:54:40 fix +LOOP (again and again)
  28. ; Wed Nov 08, 1995 20:13:58 fix TYPE once and for all (I hope)
  29.  
  30. DictStart:
  31.     DC.L    0            ; End of dictionary search
  32.     
  33.     DC.B    128+1,13,0,0        ; "{cr}" ( -- ) goto restart
  34.     DC.W    dictstart-base
  35. CRet:    MOVE.L    rzero-base(bp),rs    ; reset return stack
  36.     JMP    Restart-base(BP)    ; and jump
  37.     
  38.     DC.B    128+1,0,0,0        ; "{null}" ( -- ) same as cret
  39.     DC.W    cret-theLink
  40. NRet:    BRA.S    cret
  41.  
  42.     DC.B    128+1,'\',0,0        ; "\" ( -- ) backslash
  43.     DC.W    nret-theLink        ;  line ending comment
  44. Backsl:    bra.s    cret
  45.  
  46.     DC.B    9,'?TE'            ; "?terminal" ( -- flag )
  47.     DC.W    backsl -theLink        ;  was a key pressed?
  48. QTerm:    JSR    NextEvent-base(BP)
  49.     CLR    -(PS)
  50.     TST    kflag-base(BP)
  51.     BEQ.S    @0
  52.     SUBQ    #1,(PS)
  53.     @0:    RTS
  54.  
  55.     DC.B    3,'KEY'            ; "key" ( -- ascii )
  56.     DC.W    qterm-theLink        ;   wait for a key press
  57. Key:    BSR.S    Curs
  58.     @0:    JSR    NextEvent-base(BP)    ; set kflag if a key is pressed
  59.     TST    KFlag-base(BP)        ; ( among other things... )
  60.     BEQ.S    @0
  61.     BSR.S    NoCurs
  62.     MOVE    KFlag-base(BP),-(PS)
  63.     RTS
  64.  
  65. NoCurs:    MOVE    #10,-(SP)        ; SrcXor mode
  66.     _PenMode
  67.   Curs:    clr.l    -(sp)
  68.     addq.l    #6,(sp)
  69.     _Move
  70.     MOVE.L    #$0000FFFA,-(SP)    ; draw 6 pixels to the left
  71.     _Line
  72.     _PenNormal
  73.     RTS
  74.  
  75.     DC.B    6,'?ST'            ; "?stack" ( ? -- )
  76.     DC.W    key-theLink
  77. StkChk: CMPA.L    Szero-base(BP),PS
  78.     BGT.S    @0
  79.     RTS
  80.     @0:    JSR    space-base(BP)
  81.       MOVEQ    #42,D0            ; print *  if stack underflow
  82.     JSR    EmitCode-base(BP)
  83.     BRA.S    huh
  84.  
  85.     DC.B    7,'?BU'            ; "?button" ( -- flag )
  86.     DC.W    StkChk-theLink
  87. QButton:
  88.     CLR    -(SP)
  89.     _Button
  90.     MOVE    (SP)+,-(PS)
  91.     BEQ.S    @0
  92.     SUBI    #257,(PS)
  93.     @0:    RTS
  94.  
  95.     DC.B    6,'WHA'            ; "whazat" ( -- )
  96.     DC.W    QButton-theLink
  97. WhaZat:    jsr    dwrd-base(bp)        ; push token address
  98.     BRA.S    huh
  99.  
  100.     DC.B    5,'ABO'            ; "abort" ( -- )
  101.     DC.W    whazat-theLink
  102. huh:    MOVE.L    Szero-base(BP),PS    ; reset stack pointer < moved 5/93
  103.     MOVEQ    #63,D0            ; send ?
  104.     JSR    EmitCode-base(BP)
  105.     BSR.S    crlf
  106.     BRA.S    fin
  107.     
  108.     DC.B    4,'QUI'            ; "quit" ( -- )
  109.     DC.W    huh-theLink        ;    restart the interpreter loop
  110. fin:    JSR    emptyfs-base(BP)    ; clear pending loads
  111.     CLR.L    fcolon-base(BP)        ; clear compiling flag
  112.     BSET.B    #7,fint-base(BP)    ; reset to keyboard input
  113.     JMP    cret-base(BP)
  114.  
  115.     DC.B    2,'CR',0        ; "cr" ( -- ) output CR to screen
  116.     DC.W    fin-theLink
  117. CRLF:    JMP    doCR-Base(BP)        ; part of emit
  118.  
  119.     DC.B    3,'.OK'            ; ".ok" ( -- )
  120.     DC.W    crlf-theLink
  121. Prompt:    JSR    space-base(BP)        ; send space
  122.     MOVEQ    #111,D0
  123.     JSR    EmitCode-base(BP)    ; send "o"
  124.     MOVEQ    #107,D0
  125.     JSR    EmitCode-base(BP)    ; send "k"
  126.     JMP    space-base(BP)        ; send another space & return
  127.  
  128.     DC.B    5,'UPP'            ; "upper" ( addr -- )
  129.     DC.W    prompt-theLink        ;   change a string to upper case
  130. Upper:    MOVE    (PS)+,D0
  131.     LEA    0(BP,D0.W),A0        ; get the address
  132.     CLR    D0
  133.     MOVE.B    (A0),D0            ; get count
  134.     @0:    CMPI.B    #$60,0(A0,D0.W)        ; BEGIN  get char at addr + count
  135.     BLE.S    @1            ;   char > 'a'
  136.     CMPI.B    #$7B,0(A0,D0.W)        ;   char < 'z'
  137.     BGE.S    @1            ;   AND IF
  138.     SUBI.B    #32,0(A0,D0.W)        ;     char 32 - -> char THEN
  139.     @1:    DBRA    D0,@0            ; count 1- -> count count NOT UNTIL
  140.     RTS
  141.  
  142.     DC.B    5,'TOK'            ; "token" ( -- ) put a token
  143.     DC.W    upper-theLink        ;   from (IS) into (DP),
  144. Token:    MOVE    #32,-(PS)        ;   which is at end of dict.
  145.     BSR.S    word
  146.     JSR    here-base(BP)        ; Fri Apr 29, 1988 00:27:23 simpl
  147.     BRA.S    Upper
  148.  
  149.     DC.B    6,'HEA'            ; "header" ( -- ) create a header
  150.     DC.W    token-theLink        ;   for the current word at DP
  151. Header:    MOVE    Dict,4(DP)        ; link header to dictionary
  152.     MOVE.L    DP,Dict            ; update DICT
  153.     SUB.L    BP,Dict            ; make it a rel.addr
  154.     addq.l    #6,dp            ; update DP
  155.     RTS
  156.  
  157.     DC.B    4,'WOR'            ; "word" ( c -- ) c is delimiter
  158.     DC.W    header-theLink        ;   get chars from (IS) into HERE
  159. Word:    MOVE.L    D4,-(SP)        ; preserve the register
  160.     MOVE    (PS)+,D4        ; get delimiter character
  161.     CLR.L    (DP)            ; clear token buffer
  162.     CLR.L    D1            ; clear count
  163.     @0:    MOVE.B    (IS)+,D0        ; get characters until delimiter
  164.     CMP.B    D4,D0
  165.     BEQ.S    @1
  166.     MOVE.B    D0,1(DP,D1)        ; place in token buffer
  167.     ADDQ.B    #1,D1            ; increment count
  168.     BRA.S    @0
  169.     @1:    MOVE.B    D1,(DP)            ; put count in 1st byte of buffer
  170.     BEQ.S    @0            ; if count is 0 repeat
  171.     MOVE.L    (SP)+,D4        ; restore the register
  172.     RTS
  173.  
  174.     DC.B    1,'''',0,0        ; "'" ( -- rel.addr ) return the
  175.     DC.W    word-theLink        ;  cfa of the following word
  176. Tick:    bsr.s    token            ; get the next word
  177.     MOVE    Dict,-(PS)        ; push dict ptr to parmstk
  178.     bsr.s    search            ; lookup the current token
  179.     TST    (PS)+
  180.     BEQ    Whazat
  181.     RTS
  182.  
  183.     DC.B    6,'SEA'            ; "search" ( addr -- cfa t  OR  f )
  184.     DC.W    tick-theLink
  185. Search:    MOVE.L    (DP),D1            ; put token "stem" in D1
  186.     MOVE    (PS),D0            ; use A0 as search pointer
  187.     CLR    fmacro-base(BP)        ; clear the macro flag
  188.     @0:    LEA    0(BP,D0.W),A0        ; DO
  189.     TST    (A0)            ;   IF DictStart  exit NOFIND
  190.     BEQ.S    nofind
  191.     CMP.L    (A0),D1            ;   compare word to candidate
  192.     BEQ.S    find            ;   IF found, exit FIND
  193.     BCHG    #31,D1            ;   set immediate bit
  194.     CMP.L    (A0),D1            ;   compare to "immediate" version
  195.     BEQ.S    ifind            ;   IF found, exit IFIND
  196.     BCHG    #31,D1            ;   reset immediate bit
  197.     BCHG    #30,D1            ;   set macro bit
  198.     CMP.L    (A0),D1            ;   compare to "macro" version
  199.     BEQ.S    mfind            ;   IF found, exit MFIND
  200.     BCHG    #30,D1            ;   reset macro bit
  201.     MOVE    4(A0),D0        ;   get link rel.address
  202.     BRA.S    @0            ; LOOP
  203. nofind:    CLR    (PS)            ; push fail flag
  204.     RTS
  205.  mfind:    BSET.B    #7,fmacro-base(BP)    ; set macro flag
  206.     BRA.S    find
  207.  ifind:    BSET.B    #7,fimmed-base(BP)    ; set immediate flag
  208.   find:    LEA    6(A0),A0        ; cfa is at 6+nfa
  209.     SUBA.L    BP,A0            ; convert code address to relative
  210.     MOVE    A0,(PS)            ; push code rel address
  211.     MOVE    #-1,-(PS)        ; push success flag
  212.     RTS
  213.  
  214.     DC.B    6,'NUM'            ; "number" ( addr -- n t  OR  f )
  215.     DC.W    search-theLink
  216. Number:    MOVE.L    D4,-(SP)        ; save the register
  217.     CLR.L    D1
  218.     CLR.L    D4            ; clear conversion register
  219.     MOVE    (PS)+,D0        ; get token addr in D0
  220.     LEA    0(BP,D0.W),A0        ; put abs.addr in A0
  221.     CMPI.B    #'-',1(A0)        ; is it negative?
  222.     BNE.S    @0            ; IF yes
  223.     BSET.B    #7,fneg-base(BP)    ;     set negative flag
  224.     MOVE.B    #'0',1(A0)        ;     change dash to zero
  225.     @0:    CLR.L    D0            ; THEN
  226.     MOVE.B    (A0)+,D1        ; get digit count
  227.  digit:    MOVE.B    (A0)+,D0        ; BEGIN get next digit
  228.     SUBI.B    #48,D0            ;     strip ASCII prefix
  229.     BLT.S    @2            ;     if digit too small, FAIL
  230.     CMP    #10,D0            ;     if digit > 9
  231.     BLT.S    @1            ;     adjust for radix>10 values
  232.     SUBI.B    #7,D0            ;     and test again
  233.     CMP    #10,D0
  234.     BLT.S    @2
  235.     @1:    CMP    NBase-base(BP),D0    ;     if base < digit
  236.     BGE.S    @2            ;     FAIL
  237.     MULU    NBase-base(BP),D4    ;     multiply value by base
  238.     ADD    D0,D4            ;     add current digit
  239.     SUBQ.B    #1,D1            ;     decrement count
  240.     BNE.S    digit            ; UNTIL no digits remain
  241.         BCLR    #7,fneg-base(BP)    ; test and clear negative flag
  242.     BEQ.S    @0            ; if set
  243.     NEG    D4            ; Negate it
  244.     @0:    MOVE    D4,-(PS)        ; push number
  245.     MOVE    #-1,-(PS)        ; push success flag
  246.     BRA.S    @3
  247.     @2:    CLR    -(PS)            ; push fail flag
  248.     @3:    MOVE.L    (SP)+,D4        ; restore the register
  249.     RTS
  250.  
  251.     DC.B    7,'FNU'            ; FNUMBER ( dabs.addr -- f )
  252.     DC.W    number-theLink        ; convert string at dabs.addr to fp
  253. fnum:    MOVE.L    (PS)+,-(RS)
  254.     MOVE    #1,-(PS)
  255.     PEA    (PS)
  256.     PEA    $14(DP)
  257.     CLR    -(PS)
  258.     PEA    (PS)
  259.     FPSTR2DEC
  260.     ADDQ.L    #4,PS
  261.     CMPI    #$054E,24(DP)        ; check for NAN##
  262.     BNE.S    @0
  263. ;    move    whaError-base(bp),d0    ; vector error 6/1/93
  264. ;    jmp    0(bp,d0.w)
  265.     JMP    whazat-base(BP)
  266.     @0:    PEA    $14(DP)
  267.     SUBQ.L    #6,PS
  268.     SUBQ.L    #4,PS
  269.     PEA    (PS)
  270.     FDEC2X
  271.     RTS
  272.     
  273.     DC.B    7,'EXE'            ; "execute" ( cfa -- ) do a routine
  274.     DC.W    fnum-theLink        ;    whose cfa is on the stack
  275. EXECUTE    MOVE    (PS)+,D0        ; pop code address
  276.     JMP    0(BP,D0.W)        ; execute & return
  277.  
  278.     DC.B    8,'MCO'            ; "mcompile" ( cfa -- ) 
  279.     DC.W    Execute-theLink        ; compile subroutine bodies inline 
  280. MComp:    MOVE    (PS)+,D0
  281.     LEA    0(BP,D0.W),A0        ; addr of word
  282.     @0:    MOVE    (A0)+,D0
  283.     CMPI    #$4E75,D0        ; if its an RTS your done
  284.     BEQ.S    @1
  285.     MOVE    D0,(A2)+        ; if not, compile it
  286.     BRA.S    @0            ; do next word
  287.     @1:    RTS
  288.     
  289.     DC.B    128+9,'[CO'        ; "[compile]" ( -- )  compile
  290.     DC.W    mcomp-theLink        ;   the next immediate word
  291. bCompile:
  292.     JSR    tick-base(BP)        ; get the cfa of the next word
  293.     bra.s    compile            ;  and compile a JSR to it
  294.     
  295.     DC.B    7,'COM'            ; "compile" ( cfa -- ) compile a 
  296.     DC.W    bcompile-theLink        ;    call to the cfa on the stack
  297. COMPILE    MOVE    #$04EAB,(DP)+        ; compile "JSR d(A3)"
  298.     BRA.S    Comma            ; compile displacement value
  299.  
  300.     DC.B    9,'IMM'            ; "immediate" ( -- ) make the last
  301.     DC.W    compile-theLink        ;   word defined immediate
  302. IMMED    BSET    #7,0(BP,Dict.W)        ; set immediate bit of most recent word
  303.     RTS
  304.  
  305.     DC.B    5,'MAC'            ; "macro" ( -- ) make the last
  306.     DC.W    immed-theLink        ;   word defined an inline macro
  307. marco:    BSET    #6,0(BP,Dict.W)        ; set macro bit of most recent word
  308.     RTS
  309.  
  310.     DC.B    1,':',0,0        ; ":" ( -- ) make a header for a 
  311.     DC.W    marco-theLink        ;   word definition
  312. COLON    JSR    token-Base(BP)        ; make header
  313.     JSR    header-base(BP)
  314.     BRA.S    rbrack            ; enter compile mode
  315.     
  316.     DC.B    129,']',0,0        ; "]" ( -- ) enter compile mode
  317.     DC.W    colon-theLink
  318. rBrack:    BSET    #7,fcolon-base(BP)    ; set colon flag
  319.     RTS
  320.  
  321.     DC.B    129,';',0,0        ; ";" ( -- ) end a word definition
  322.     DC.W    rBrack-theLink
  323. SEMI    MOVE    #$4E75,(DP)+        ; compile "RTS"
  324.     BRA.S    lbrack
  325.     
  326.     DC.B    129,'[',0,0        ; "[" ( -- ) leave compile mode
  327.     DC.W    semi-theLink
  328. lBrack:    CLR.B    fcolon-base(BP)        ; clear colon flag
  329.     RTS
  330.     
  331.     DC.B    7,'LIT'            ; "literal" compiling: ( n -- )
  332.     DC.W    lBrack-theLink        ;   executing: ( -- n )
  333. LITERAL    MOVE    #$03D3C,(DP)+        ; compile move #xxxx,-(PS)
  334.     BRA.S    Comma            ; compile constant
  335.  
  336.     DC.B    64+1,',',0,0        ; "," ( n -- )
  337.     DC.W    literal-theLink
  338. COMMA    MOVE    (PS)+,(DP)+        ; pop number to dictionary
  339.     RTS
  340.  
  341.     DC.B    8,'FLI'        ; FLITERAL ( comp: n5 n4 n3 n2 n1 -- |exec: -- n5 n4 n3 n2 n1 )
  342.     DC.W    comma-theLink
  343. flit:    MOVE    (PS),D0
  344.     MOVE    2(PS),D1
  345.     MOVE    8(PS),(PS)
  346.     MOVE    6(PS),2(PS)
  347.     MOVE    D0,8(PS)
  348.     MOVE    D1,6(PS)
  349.     MOVEQ    #4,D0
  350.     @0:    bsr.s    literal
  351.     DBRA    D0,@0
  352.     RTS
  353.  
  354.     DC.B    128+2,',$',0        ; ",$" ( -- )
  355.     DC.W    flit-theLink        ; compile a hex number from input
  356. CommaH:    MOVE    NBase-base(BP),-(RS)
  357.     MOVE    #$10,nbase-base(BP)
  358.     JSR    token-base(BP)
  359.     BSR.S    here
  360.     JSR    number-base(BP)
  361.     MOVE    (RS)+,nbase-base(BP)
  362.     TST    (PS)+
  363.     BEQ    whazat
  364.     BRA.S    comma
  365.  
  366.     DC.B    4,'HER'            ; "here" ( -- addr )
  367.     DC.W    commah-theLink        ;   rel.addr of compile point
  368. here:     MOVE.L    DP,-(PS)
  369.     BRA.S    torel
  370.  
  371.     DC.B    8,'DLI'            ; "dliteral" compiling: ( d -- )
  372.     DC.W    here-theLink        ;   executing: ( -- d )
  373. DLit:    MOVE    #$2D3C,(DP)+        ; compile move.l #xxxx,-(PS)
  374.     MOVE.L    (PS)+,(DP)+        ; compile double number
  375.     RTS
  376.  
  377.     DC.B    4,'>RE'            ; ">rel" (to-rel) ( rel.uu) (rel.ah)
  378.     DC.W    dlit-theLink        ; ( daddr32 -- addr16 )
  379. toRel:    MOVE.L    (PS)+,D0        ; get the Daddr32 from stack
  380.     SUB.L    BP,D0            ; get difference from base addr
  381.     MOVE    D0,-(PS)        ; push the 16 bit part of it
  382.     RTS
  383.  
  384.     DC.B    5,'COU'            ; "count" ( addr -- addr+1 length )
  385.     DC.W    torel-theLink
  386. Count:    CLR    D1
  387.     MOVE    (PS),D0
  388.     MOVE.B    0(BP,D0.W),D1
  389.     ADDQ    #1,(PS)
  390.     MOVE    D1,-(PS)
  391.     RTS
  392.  
  393.     DC.B    64+3,'+MD'        ; "+MD" ( offset -- addr )
  394.     DC.W    count-theLink
  395. MacDat:    ADDI    #theWindow-base,(PS)    ; add data addr to stacked offset
  396.     RTS
  397.     
  398.     DC.B    4,'PAG'            ; "page" ( -- )
  399.     DC.W    macdat-theLink        ; clear the window
  400. Page:    PEA    WContRect-base(BP)    ; The visable part of the window.
  401.     _EraseRect
  402.     MOVE.l    #$90001,-(SP)
  403.     _MoveTo                ; set pen position to home (1,9)
  404.     _PenNormal            ; 1X1, black, patcopy
  405.     MOVE.l    #$40000,-(SP)
  406.     _TextFont            ; Monaco
  407.     _TextFace            ; plain text
  408.     MOVE.l    #$90000,-(SP)
  409.     _TextSize            ; 9 point
  410.     _TextMode            ; srcCopy
  411.     RTS
  412.  
  413.     DC.B    4,'BEE'            ; "beep" ( -- )
  414.     DC.W    page-theLink
  415. Beep:    MOVE.W    #3,-(SP)
  416.     _SysBeep
  417.     RTS
  418.  
  419.     DC.B    64+3,'MON'        ; "mon" ( -- ) execute _Debugger
  420.     DC.W    beep-theLink
  421. Mon:    _DeBugger
  422.     RTS
  423.  
  424.     DC.B    3,'BYE'            ; "bye" ( -- ) set quit flag
  425.     DC.W    mon-theLink
  426. Bye:    ADDQ    #1,doneFlag-base(BP)
  427.     RTS
  428.  
  429. TexD:    DC.W    'TEXT'
  430.  
  431.     DC.B    4,'OPE'            ; "open" ( -- vrefnum )
  432.     DC.W    bye-theLink
  433. Open:    MOVE.L    #$4B0037,-(SP)        ; point: 75,55
  434.     CLR.L    -(SP)            ; no prompt
  435.     CLR.L    -(SP)            ; no filter
  436.     MOVE    #1,-(SP)        ; 1 type
  437.     PEA    texd-base(BP)
  438.     CLR.L    -(SP)            ; no hook
  439.     PEA    (A2)            ; put sfreply at here
  440.     MOVE    #2,-(SP)
  441.     _Pack3                ; _sfreply
  442.     TST    (A2)            ; check 'good' field
  443.     BEQ.S    beep            ; beep if cancel
  444.  
  445.     MOVE    6(A2),-(PS)        ; hold the vrefnum on stack        ***
  446.     CLR    D0
  447.     @0:    MOVE.L    10(A2,D0.W),40(A2,D0.W)    ; move the file name to PAD
  448.     ADDQ    #4,D0
  449.     CMP    #32,D0
  450.     BLE.S    @0
  451.     ADDQ    #1,openFlag-base(BP)
  452.     RTS
  453.  
  454.     DC.B    3,'-->'            ; "-->" ( -- )
  455.     DC.W    open-theLink
  456. Load:    JSR    token-base(BP)        ; put filename string at HERE
  457.     CLR    -(PS)            ; set vrefnum to 0 (path is specified)
  458.     BRA.S    load1
  459.     
  460. doLoad:
  461.     lea    40(a2),a0        ; Move the file name from PAD to HERE
  462.     move.l    a2,a1
  463.     moveq    #32,d0
  464.     _blockmove
  465.  
  466. ;    CLR    D0            ; Move the file name from PAD to HERE
  467. ;   @0:    MOVE.L    40(A2,D0.W),0(A2,D0.W)    ; 
  468. ;    ADDQ    #4,D0            ; 
  469. ;    CMP    #32,D0            ; 
  470. ;    BLE.S    @0
  471.  
  472.  load1:    MOVE    fsptr-base(BP),D0    ; get file stack pointer
  473.     BMI.S    @1            ;  ... save the offset into text ...
  474.     LEA    fofsets-base(BP),A0    ;  ... at fofsets+fspointer
  475.     MOVE.L    TextO-base(BP),0(A0,D0.W)
  476.     LEA    fends-base(BP),A0    ;  TextE at fends+fspointer
  477.     MOVE.L    TextE-base(BP),0(A0,D0.W)
  478.     @1:    ADDQ    #4,fsptr-base(BP)    ; increment the file stack pointer
  479.     
  480.     MOVE.L    #80,D0            ; create an 80 byte block for
  481.     _NewPtr.CLEAR            ; make the file control buffer
  482.     MOVE.L    A0,A4            ; save it for later
  483.     MOVE.B    #1,27(A0)        ; set read only permission
  484.     MOVE.L    DP,18(A0)        ; set name pointer
  485.     MOVE    (PS)+,22(A0)        ; set vrefnum (working directory)
  486.     _HOpen
  487.     TST    16(A0)
  488.     BNE.S    derror
  489.     _GetEOF                ; get ...
  490.     MOVE.L    28(A0),36(A0)        ;  ... and set ...
  491.     MOVE.L    28(A0),-(PS)        ;  ... and hold the file size
  492.     
  493.     MOVE.L    (PS),D0            ; set block size = file size
  494.     _NewHandle
  495.     BMI.S    derror
  496.     
  497.     MOVE    fsptr-base(BP),D0    ; get file stack pointer
  498.     LEA    fstack-base(BP),A1    ; file stack address
  499.     MOVE.L    A0,0(A1,D0.W)        ; stash the handle at fstack+(fsptr)
  500.     _HLock
  501.     
  502.     MOVE.L    (A0),A0            ; get start addr of block
  503.     MOVE.L    A0,TextO-base(BP)    ; set buffer start
  504.     MOVE.L    A0,D0            ; set buffer end ...
  505.     ADD.L    (PS)+,D0
  506.     MOVE.L    D0,TextE-base(BP)    ;  ... to start + size
  507.     
  508.     MOVE.L    A4,A0            ; retrieve fcb pointer
  509.     MOVE.L    TextO-base(BP),32(A0)    ; set read buffer addr in fcb
  510.     _Read                ; read data from file ...
  511.     TST    16(A0)            ; ... to scrap buffer
  512.     BNE.S    derror
  513.     _Close
  514.     _DisposPtr
  515.     JMP    go-base(BP)        ; interpret scrap buffer
  516.  
  517. DError:    MOVE    16(A0),-(PS)
  518.     _Close
  519.     _DisposPtr
  520.     JSR    pquote-base(BP)
  521.     DC.B    5,'Disk:'        ; print the error messsage
  522.    der:    JSR    dot-base(BP)        ; report the error number
  523.   der1:    JMP    huh-base(BP)
  524.  
  525. ;        DC.B    3,'REZ'        ; Return the handle to a resource
  526. ;        DC.W    load-theLink    ; ( ID type -- handle t or f )
  527. ;    Rez:    CLR.L    -(SP)
  528. ;        MOVE.L    (PS)+,-(SP)
  529. ;        MOVE    (PS)+,-(SP)
  530. ;        _GetResource
  531. ;        MOVE.L    (SP)+,D0    ; nil handle means error
  532. ;        BEQ.S    gser2
  533. ;        MOVE.L    D0,-(PS)
  534. ;        MOVE    #-1,-(PS)
  535. ;        RTS
  536.  
  537.     DC.B    8,'?GE'        ; "?GESTALT"
  538.     DC.W    load-theLink    ; ( d.selector -- d.response true or false )
  539. QGestalt:        ; false if 64K ROM or no _Gestalt or bad selector
  540.     ; check for 64K ROM
  541.     MOVE    #$A86E,D0        ; _InitGraf
  542.     _GetTrapAddress.newTool
  543.     MOVE.L    A0,D1
  544.     MOVE    #$AA6E,D0        ; _InitGraf AND $200
  545.     _GetTrapAddress.newTool
  546.     CMP.L    A0,D1
  547.     BEQ.S    gser1            ; 64KROM
  548.  
  549.     ; Check for gestalt
  550.     MOVE.W    #$A89F,D0        ; _Unimplemented
  551.     _GetTrapAddress.newTool        ; NGetTrapAddress
  552.     MOVE.L    A0,D1
  553.     MOVE.W    #$A1AD,D0        ; _Gestalt
  554.     _GetTrapAddress.newOS        ; NGetTrapAddress
  555.     CMP.L    A0,D1
  556.     BEQ.S    gser1            ; no gestalt
  557.  
  558.     ; run gestalt
  559.     MOVE.L    (PS)+,D0
  560.     _Gestalt
  561.     BNE.S    gser2
  562.     MOVE.L    A0,-(PS)        ; return the result  ... and ...
  563.     MOVE    #-1,-(PS)        ; return true
  564.  gsret:    RTS
  565.  
  566.  gser1:    ADDQ.L    #4,PS            ; gestalt error
  567.  gser2:    CLR    -(PS)            ; return false
  568.     RTS
  569.  
  570.     DC.B    128+2,',S',0        ; ",S" compile a dnumber from ascii
  571.     DC.W    qgestalt-theLink    ; NOTE: 1 and only 1 space seperates
  572. CommaS:    MOVE.L    A2,A0
  573.     MOVEQ    #4,D0
  574.     @0:    MOVE.B    (IS)+,(A0)+
  575.     DBRA    D0,@0
  576.     MOVE.L    (A2),-(PS)
  577.  
  578.     TST.B    fcolon-base(BP)
  579.     BEQ.S    gsret
  580.     JMP    dlit-base(BP)
  581.  
  582.     DC.B    64+9,'INT'        ; "interpret"
  583.     DC.W    commas-theLink
  584. Interp:    JMP    main-base(BP)
  585.     RTS            ; <- gotta have this for mcompile
  586.  
  587.     DC.B    4,'ROO'            ; "room" ( -- bytes )
  588.     DC.W    interp-theLink
  589. Room:    MOVE.L    A3,A0
  590.     _RecoverHandle            ; use handle rather than pointer
  591.     _GetHandleSize
  592.     MOVE.L    A3,A0            ; Bottom
  593.     ADDA.L    D0,A0            ;  +  block size ...
  594.     SUBA.L    A2,A0            ;  -  end of dictionary
  595.     MOVE    A0,-(PS)        ;  =  unused dictionary space
  596.     RTS
  597.  
  598. CSave:    CLR    -(SP)            ; Room for which item number.
  599.     MOVE    #259,-(SP)        ; Resource ID of ALRT
  600.     CLR.L    -(SP)
  601.     _Alert                ; About Item
  602.     SUBQ    #1,(SP)+        ; check which item dismissed.
  603.     BEQ.S    save            ; save if 'ok'
  604.     RTS
  605.  
  606.     DC.B    4,'SAV'            ; "save" ( -- ) save the dictionary
  607.     DC.W    room-theLink
  608. Save:    JSR    here-base(BP)
  609.     MOVE    (PS)+,freePt-base(BP)    ; save current DP
  610.     MOVE    Dict,DictPt-base(BP)    ; save current DictPt
  611.     BSR.S    room
  612.     MOVE    (PS),freesz-base(BP)    ; save current headroom
  613.     BSR.S    negate
  614.     BSR.S    grow            ; reduce headroom to 4 bytes
  615.     move.l    a3,A0            ; bottom
  616.     _RecoverHandle            ; get DICT's handle
  617.     CLR    -(SP)
  618.     MOVE.L    A0,-(SP)        ; push 2, 1 for each operation
  619.     MOVE.L    A0,-(SP)
  620.     _ChangedResource
  621.     _HomeResFile
  622.     _UpdateResFile            ; write out the DICT
  623.     MOVE    freesz-base(BP),-(PS)
  624. Grow:    JSR    here-base(BP)
  625.     MOVE    (PS)+,D1        ; hold rel DP in D1
  626.     MOVE.L    IS,-(PS)
  627.     JSR    torel-base(BP)
  628.     MOVE    (PS)+,D2
  629.     MOVE.L    (RS),-(PS)
  630.     JSR    torel-base(BP)
  631.     JSR    swapp-base(BP)
  632.     MOVEA.L    expand-base(BP),A0
  633.     JMP    (A0)            ; JSR won't return here
  634.  
  635.     DC.B    4,'>AB'            ; ">abs" (to-abs)
  636.     DC.W    save-theLink        ; ( addr16 -- daddr32 )
  637. toAbs:    CLR.L    D0
  638.     MOVE    (PS)+,D0        ; pop rel addr
  639.     LEA    0(BP,D0.W),A0        ; calc as offset to base ...
  640.     MOVE.L    A0,-(PS)        ; ...  and push
  641.     RTS
  642.  
  643.     DC.B    64+6,'NEG'        ; "negate" ( n -- -n )
  644.     DC.W    toabs-theLink
  645. negate:    NEG    (PS)
  646.     RTS
  647.  
  648.     DC.B    5,'SPA'            ; "space" ( -- ) emit a space
  649.     DC.W    negate-theLink
  650. space:    MOVE.L    #32,D0
  651.     bra.s    emitcode
  652.  
  653.     DC.B    4,'TYP'            ; "type" ( rel.addr len -- )
  654.     DC.W    space-theLink        ;  emit len characters from rel.addr
  655. Type:    MOVEM.L    D3/D4,-(SP)        ; don't trash registers!
  656.     MOVE    (PS)+,D3        ; get character count
  657.     MOVE    (PS)+,D4        ; get string relative address
  658.     @0:    SUBQ    #1,D3
  659.         BMI.S    @1
  660.     MOVE.B    0(BP,D4.W),D0        ; get character byte
  661.     bsr.s    emitcode        ; print character byte
  662.     ADDQ    #1,D4
  663.     BRA.S    @0
  664.     @1:    MOVEM.L    (SP)+,D3/D4        ; restore registers
  665.     rts
  666.  
  667. pQuote:    ;   runtime part of ."
  668.     MOVE.L    (RS),-(PS)        ; push the addr of the string
  669.     JSR    torel-base(BP)
  670.     ADDQ    #1,(PS)            ; skip the length byte
  671.     MOVE.L    (RS),A0
  672.     CLR.L    D0            ; clear the character count
  673.     MOVE.B    (A0),D0            ; get the length
  674.     MOVE    D0,-(PS)        ; push it
  675.     ADDQ    #2,D0
  676.     ANDI    #$FFFE,D0        ; be sure its even
  677.     ADD.L    D0,(RS)            ; skip over string upon return
  678.     bra.s    type            ; type the string
  679.     
  680.     DC.B    4,'EMI'            ; "emit" ( n -- ) send the ascii
  681.     DC.W    type-theLink        ;                 to the terminal
  682. Emit:    MOVE    (PS)+,D0
  683.   EmitCode:                ; Emit contents of D0
  684.     CMP.B    #13,D0            ; is it a <cr>
  685.     BEQ.S    doCR
  686.     CMP.B    #8,D0            ; is it a <del>?
  687.     BEQ.S    doDEL
  688.     ANDI    #$FF,D0
  689.     MOVE    D0,-(A7)
  690.     _DrawChar
  691.     BSR.S    penh
  692.     MOVE    WContRect+6-base(BP),D0    ; right coord of WContRect
  693.     CMP    D0,D1            ; is the position beyond the edge
  694.     BLS.S    emitr            ; no
  695.     
  696.   doCR:    PEA    Scratch-base(BP)
  697.     _GetPen
  698.     MOVE    Scratch-base(BP),D1
  699.     MOVE    WContRect+4-base(BP),D0    ; bottom coord of WContRect
  700.     SUB    #11,D0
  701.     CMP    D0,D1            ; is the position below the window
  702.     BLS.S    @0            ; no
  703.  
  704.     ; yes it is below the bottom of the window, so scroll up 11 pixels
  705.     CLR.L    -(A7)            ; Make room for a region handle.
  706.     _NewRgn                ; get handle into (A7)
  707.     PEA    WContRect-base(BP)    ; rect to scroll
  708.     CLR    -(A7)            ; no horiz.
  709.     MOVE    #$FFF5,-(A7)        ; 11 pix. vert.
  710.     MOVE.L    8(A7),-(A7)        ; push the region handle
  711.     _ScrollRect
  712.     _DisposRgn
  713.  
  714.     MOVE    WContRect+4-base(BP),D1    ; bottom coord of WContRect
  715.     SUBQ    #4,D1
  716.     BRA.S    @1
  717.  
  718.     @0: ADD    #11,D1            ; Add line height to pen location
  719.     @1:    MOVE    #1,-(A7)
  720.     MOVE    D1,-(A7)
  721.     _MoveTo
  722.  emitr:    RTS
  723.  
  724.  doDEL:    BSR.S    penh
  725.     CMP    #6,D1            ; first column?
  726.     blt.s    @0            ; don't beep anymore
  727.     SUB    #6,D1            ; back up
  728.     MOVE    D1,-(SP)
  729.     MOVE    Scratch-base(BP),-(SP)
  730.     _MoveTo
  731.     @0:    RTS
  732.  
  733.   penh:    PEA    Scratch-base(BP)
  734.     _GetPen
  735.     MOVE    Scratch+2-base(BP),D1
  736.     RTS
  737.  
  738.     DC.B    6,'EXP'            ; "expect" ( addr count -- )
  739.     DC.W    emit-theLink
  740. Expect:    MOVEM.L    D4/IS,-(SP)
  741.     JSR    swapp-base(BP)        ; leave number of chars on stack
  742.     MOVE    (PS)+,D0        ; addr
  743.     LEA    0(BP,D0.W),IS        ; set IS to the input address
  744.     CLR    Counter
  745.     MOVE    (PS)+,D4
  746.     @0:    JSR    key-base(BP)
  747.     MOVE    (PS)+,D5
  748.     CMPI    #CR,D5            ; if key = CR
  749.     BNE.S    @1
  750.     MOVE.B    #BL,0(IS,Counter)
  751.     CLR.B    1(IS,Counter)
  752.     MOVE.B    #BL,2(IS,Counter)
  753.     BRA.S    @3
  754.     @1:    CMPI    #BS,D5            ; if key = backspace
  755.     BNE.S    @2
  756.     TST    Counter            ; do nothing if first key is BS
  757.     BEQ.S    @0
  758.     SUBQ    #1,Counter        ; decriment counter
  759.     bSR.s    dodel    ; -base(BP)
  760.     JSR    space-base(BP)        ;    ... rubout char
  761.     bSR.s    dodel    ; -base(BP)
  762.     BRA.S    @0
  763.     @2:    MOVE.B    D5,0(IS,Counter)    ; stash the key into input buffer
  764.     ADDQ    #1,Counter
  765.     MOVE    D5,D0
  766.     JSR    emitcode-base(BP)
  767.     CMP    D4,Counter        ; is count=number of chars to get?
  768.     BNE.S    @0
  769.     @3:    JSR    docr-base(BP)
  770.     MOVEM.L    (SP)+,D4/IS
  771.     RTS
  772.  
  773.     DC.B    64+1,'0',0,0        ; "0" ( -- 0 )
  774.     DC.W    expect-theLink
  775. Zero:    CLR    -(PS)
  776.     RTS
  777.     
  778.     DC.B    64+4,'DRO'        ; "drop" ( n -- )
  779.     DC.W    zero-theLink
  780. drop:    ADDQ.L    #2,PS
  781.     RTS
  782.  
  783.     DC.B    4,'SWA'            ; "swap" ( n1 n2 -- n2 n1 )
  784.     DC.W    drop-theLink
  785. swapp:    MOVE.L    (PS)+,D0
  786.     SWAP    D0
  787.     MOVE.L    D0,-(PS)
  788.     RTS
  789.  
  790.     DC.B    64+5,'2DR'        ; "2drop" ( d -- )
  791.     DC.W    swapp-theLink
  792. TwoDrop:
  793.     ADDQ.L    #4,PS
  794.     RTS
  795.  
  796.     DC.B    4,'NUL'            ; "null" ( -- )
  797.     DC.W    twodrop-theLink
  798. Null:    RTS
  799.  
  800.     dc.b    4,'WAR'            ; "warm" ( ? -- )
  801.     dc.w    null-theLink        ; added 6/1/93
  802. WarmSt:    jmp    warm-base(bp)
  803.     
  804.     DC.B    6,'FOR'            ; "forget" ( -- ) forgets dictionary
  805.     DC.W    warmst-theLink
  806. Forget:    JSR    tick-base(BP)
  807.     MOVE    (PS)+,D0
  808.     MOVE    -2(BP,D0.W),Dict
  809.     LEA    -6(BP,D0.W),DP
  810.     RTS
  811.  
  812.     DC.B    8,'CON'            ; "constant" compile: ( n16 -- )
  813.     DC.W    forget-theLink    ;            runtime: ( -- n16 )
  814. Const:    JSR    token-base(BP)        ; make a header for the next token
  815.     JSR    header-base(BP)
  816.     JSR    marco-base(BP)        ; to return a constant
  817.     JSR    literal-base(BP)    ; compile time comma, runtime push
  818.     MOVE    #$4E75,(DP)+        ; compile  rts 
  819.     RTS
  820.  
  821.     DC.B    6,'CRE'            ; "create" compile: ( -- ) 
  822.     DC.W    const-theLink        ;          runtime: ( -- addr16 )
  823. Create:    JSR    token-base(BP)        ; give token this runtime action:
  824.     JSR    header-base(BP)
  825.     MOVE    #$3D3C,(DP)+        ;  • move     #nnnn,-(ps)
  826.     JSR    here-base(BP)
  827.     ADDQ    #6,(PS)
  828.     MOVE    (PS)+,(DP)+        ; supply the nnnn from above
  829.     MOVE    #$4EEB,(DP)+        ;  • jmp     null-base(bp)
  830.     MOVE.L    DP,DoesAddr-base(BP)    ; set DoesAddr to this "null"
  831.     MOVE    #null-base,(DP)+
  832.     RTS
  833.  
  834.     DC.B    5,'DOE'            ; "does>" ( -- ) (use after create)
  835.     DC.W    create-theLink        ;   set runtime action 
  836. Does:    MOVE.L    (RS)+,D0        ; pop the return address
  837.     SUB.L    BP,D0            ; convert to rel.addr
  838.     MOVE.L    DoesAddr-base(BP),A0    ; load jmp d(bp) address from create
  839.     MOVE    D0,(A0)            ; and stash rel.addr into it
  840.     RTS                ; returns same as ;
  841.  
  842.     DC.B    5,'ALL'            ; "allot" ( n16 -- )
  843.     DC.W    does-theLink        ;  compiles nada into the dictionary
  844. Allot:    ADDQ    #1,(PS)
  845.     ANDI    #$FFFE,(PS)        ; make it even!
  846.     ADDA    (PS)+,DP        ; increment the dictionary pointer
  847.     RTS
  848.  
  849.     DC.B    8,'VAR'            ; "variable" compile: ( -- )
  850.     DC.W    allot-theLink        ;            runtime: ( -- addr16 )
  851. Variable:
  852.     JSR    token-base(BP)        ; give token this runtime action:
  853.     JSR    header-base(BP)
  854.     JSR    marco-base(BP)        ; Sun May 1, 1988 04:24:44
  855.     MOVE    #$3D3C,(DP)+        ;  • move   #nnnn,-(ps)
  856.     JSR    here-base(BP)
  857.     ADDQ    #4,(PS)            ;    calculate nnnn
  858.     MOVE    (PS)+,(DP)+        ;  • (this is the nnnn)
  859.     MOVE    #$4E75,(DP)+        ;  • rts
  860.     ADDQ.L    #2,DP            ; 2 allot
  861.     RTS
  862.  
  863.     DC.B    3,'AE:'
  864.     DC.W    variable-theLink
  865. aColon:    MOVE    #AEvents-base,-(PS)
  866.     @0:    JSR    at-base(BP)
  867.     ADDI    #10,(PS)
  868.     MOVE    (PS),-(PS)
  869.     JSR    at-base(BP)
  870.     TST    (PS)+
  871.     BNE.S    @0
  872.     MOVE    (PS)+,D1
  873.     MOVE.L    A2,D0
  874.     SUB.L    BP,D0
  875.     MOVE    D0,0(BP,D1.W)
  876.     MOVE.L    (PS)+,(A2)+
  877.     MOVE.L    (PS)+,(A2)+
  878.     LEA    4(A2),A0
  879.     SUBA.L    A3,A0
  880.     MOVE    A0,(A2)+
  881.     CLR    (A2)+
  882.     MOVE    #$4EBA,(A2)+
  883.     MOVE    #aepre-base,-(PS)
  884.     JSR    back-base(BP)
  885.     JMP    rbrack-base(BP)
  886.  
  887.     DC.B    128+3,';AE'
  888.     DC.W    acolon-theLink
  889. semiae:    MOVE    #$4EAB,(A2)+        ; • jsr aepost(bp)
  890.     MOVE    #aepost-base,(A2)+    ; • rts
  891.     JMP    semi-base(BP)
  892.  
  893.     DC.B    64+5,'>NA'        ; ">name" ( 'addr -- name.addr )
  894.     DC.W    semiae-theLink
  895. toname:    SUBQ    #6,(PS)
  896.     RTS
  897.     
  898.     DC.B    64+5,'>LI'        ; ">link" ( 'addr -- link.addr )
  899.     DC.W    toname-theLink
  900. tolink:    SUBQ    #2,(PS)
  901.     RTS
  902.  
  903.     DC.B    3,'ID.'            ; "id." ( addr -- )
  904.     DC.W    tolink-theLink
  905. IDDot:    JSR    toname-base(BP)
  906.     MOVEA.L    DP,A0
  907.     MOVEQ.L    #5,D0
  908.     @0:    MOVE.L    #$C9C9C9C9,(A0)+    
  909.     DBRA    D0,@0
  910.     MOVE    (PS)+,D0
  911.     MOVE.L    0(BP,D0.W),(DP)
  912.     JSR    here-base(BP)
  913.     MOVE    (PS),-(PS)
  914.     JSR    cat-base(BP)
  915.     ANDI    #$1F,(PS)        ; look at 5 lsb's
  916.     ADDQ    #1,2(PS)
  917.     JSR    type-base(BP)
  918.     JMP    space-base(BP)
  919.     
  920.     DC.B    5,'WOR'            ; "words" ( -- ) list words
  921.     DC.W    iddot-theLink
  922. Words:    MOVE.L    D3,-(SP)        ; preserve register
  923.     MOVE    Dict,D3            ; start with the last word defined
  924.     @0:    MOVE    D3,-(PS)        ; push the name address
  925.     ADDQ    #6,(PS)            ; get the CFA
  926.     BSR.S    iddot            ; print the name
  927.      MOVE    4(BP,D3.W),D3        ; put the next name addr into D3
  928.     TST.B    1(BP,D3.W)        ; Quit if name is 0
  929.     BEQ.S    @1            ; do next word if not=0
  930.     JSR    qterm-base(BP)
  931.         TST    (PS)+
  932.     BEQ.S    @0
  933.     @1:    MOVE.L    (SP)+,D3        ; restore register
  934.     RTS
  935.     
  936.     DC.B    3,'PAD'            ; "pad" ( -- ) conversion pad
  937.     DC.W    words-theLink
  938. Pad:    JSR    here-base(BP)
  939.     ADDI    #40,(PS)        ; pad is 40 bytes from HERE.
  940.     RTS
  941.     
  942.     DC.B    4,'HOL'            ; "hold" ( c -- ) place c at ...
  943.     DC.W    pad-theLink        ; ... addr in Held.
  944. Hold:    SUBQ    #1,held-base(BP)
  945.     MOVE    held-base(BP),-(PS)
  946.     JMP    cstore-base(BP)
  947.     
  948.     DC.B    4,'SIG'            ; "sign" ( sf dval -- dval )
  949.     DC.W    hold-theLink
  950. Sign:    JSR    rote-base(BP)
  951.     TST    (PS)+
  952.     BGE.S    @0
  953.     MOVE    #'-',-(PS)
  954.     BSR.S    hold
  955.     @0:    RTS
  956.  
  957.     DC.B    4,'DAB'            ; "dabs" ( dval -- |dval| )
  958.     DC.W    sign-theLink
  959. Dabs:    TST    (PS)
  960.     BGE.S    @0
  961.     JSR    dneg-base(BP)
  962.     @0:    RTS
  963.  
  964.     DC.B    2,'<#',0        ; "<#" ( -- )
  965.     DC.W    dabs-theLink
  966. LSharp:    BSR.S    pad
  967.     MOVE    (PS)+,held-base(BP)
  968.     MOVEA.L    DP,A0
  969.     MOVE    #9,D0
  970.     @0:    CLR.L    (A0)+
  971.     DBRA    D0,@0
  972.     MOVE    #30,-(PS)
  973.     BRA.S    hold
  974.  
  975.     DC.B    2,'#>'.0        ; "#>" ( dval -- addr len )
  976.     DC.W    lsharp-theLink
  977. SharpG:    ADDQ.L    #2,PS
  978.     MOVE    held-base(BP),(PS)
  979.     BSR.S    pad
  980.     MOVE    2(PS),-(PS)        ; over
  981.     ADDQ    #1,(PS)
  982.     JMP    minus-base(BP)
  983.     
  984.     DC.B    1,'#',0,0        ; "#" ( dval -- d/base )
  985.     DC.W    sharpg-theLink
  986. Sharp:    MOVE    NBase-base(BP),-(PS)
  987.     JSR    msmod-base(BP)
  988.     JSR    rote-base(BP)
  989.     CMPI    #9,(PS)            ; is top of stack < 9?
  990.     BLE.S    @0
  991.     ADDQ    #7,(PS)
  992.     @0:    ADDI    #48,(PS)
  993.     JMP    hold-base(BP)
  994.  
  995.     DC.B    2,'#S',0        ; "#s" ( dval -- 0 0 )
  996.     DC.W    sharp-theLink
  997. Sharps:    BSR.S    sharp
  998.     TST.L    (PS)
  999.     BNE.S    sharps
  1000.     RTS
  1001.  
  1002.     DC.B    2,'D.',0        ; "d." ( dval -- )
  1003.     DC.W    sharps-theLink
  1004. DDot:    JSR    swapp-base(BP)
  1005.     MOVE    2(PS),-(PS)
  1006.     JSR    dabs-base(BP)
  1007.     BSR.S    lsharp
  1008.     BSR.S    sharps
  1009.     JSR    sign-base(BP)
  1010.     BSR.S    sharpg
  1011.     jsr    type-base(BP)
  1012.     jmp    space-base(bp)
  1013.  
  1014.     DC.B    2,'U.',0        ; "u." ( uval -- )
  1015.     DC.W    ddot-theLink
  1016. UDot:    CLR    -(PS)
  1017.     BRA.S    ddot
  1018.  
  1019.     DC.B    3,'S>D'            ; "s>d" ( n -- d )
  1020.     DC.W    udot-theLink
  1021. SToD:    MOVE    (PS),-(PS)        ; dup
  1022.     JMP    zerolt-base(BP)        ; 0<
  1023.  
  1024.     DC.B    1,'.',0,0        ; "." ( n -- )
  1025.     DC.W    stod-theLink
  1026. Dot:    BSR.S    stod
  1027.     BRA.S    ddot
  1028.  
  1029.     DC.B    130,'."',0        ; "."" ( -- ) compiler part of (.")
  1030.     DC.W    dot-theLink
  1031. dotQ:    MOVE    #pQuote-base,-(PS)
  1032.     JSR    compile-base(BP)    ; compile a call to (.")
  1033.     JSR    here-base(BP)        ; ( -- addr )
  1034.     MOVE    #'"',-(PS)        ; ( -- addr 34 )
  1035.     JSR    word-base(BP)        ; ( -- addr )
  1036.     JSR    cat-base(BP)        ; ( -- count )
  1037.     ADDQ    #1,(PS)            ; ( -- count+1 )
  1038.     JMP    allot-base(BP)        ; enclose the string in dictionary
  1039.     
  1040.     DC.B    129,'(',0,0        ; "(" ( -- ) begin comment
  1041.     DC.W    dotq-theLink
  1042. Comment    CMPI.B    #41,(IS)+        ; read in characters until ")"
  1043.     BNE.S    Comment
  1044.     RTS
  1045.  
  1046.     DC.B    5,'CMO'            ; "cmove" ( addr1 addr2 len -- )
  1047.     DC.W    comment-theLink        ; from figFORTH, fixed 8/3/91
  1048. CMove:    MOVE    (PS)+,D0        ; D0 = length
  1049.     MOVE    (PS)+,D1
  1050.     LEA    0(BP,D1.W),A1        ; A1 = addr2
  1051.     MOVE    (PS)+,D1
  1052.     LEA    0(BP,D1.W),A0        ; A0 = addr1
  1053.     CMPA.L    A0,A1
  1054.     BPL.S    @2
  1055.  
  1056.     BRA.S    @1            ;  addr1 > addr2
  1057.     @0:    MOVE.B    (A0)+,(A1)+
  1058.     @1:    DBRA    D0,@0
  1059.     RTS
  1060.  
  1061.     @2:    ADDA    D0,A0            ;  addr1 ≤ addr2
  1062.     ADDA    D0,A1
  1063.     BRA.S    @4
  1064.     @3:    MOVE.B    -(A0),-(A1)
  1065.     @4:    DBRA    D0,@3
  1066.     RTS
  1067.     
  1068.     DC.B    4,'FIL'            ; "fill" ( addr count char -- )
  1069.     DC.W    cmove-theLink
  1070. Fill:    MOVE    (PS)+,D0        ; character
  1071.     MOVE    (PS)+,D1        ; count
  1072.     SUBQ    #1,D1            ; decrement count
  1073.     MOVE    (PS)+,A0        ; relative addr
  1074.     LEA    0(BP,A0.W),A0        ; get absolute addr
  1075.     @0:    MOVE.B    D0,0(A0,D1.W)        ; put char into addr + count
  1076.         DBRA    D1,@0            ; decrement count & loop until 0
  1077.     RTS
  1078.     
  1079.     DC.B    9,'-TR'            ; "-trailing"
  1080.     DC.W    fill-theLink        ;  ( addr count -- addr new.count )
  1081. dtrail:    MOVE    (PS)+,D1        ; get the count
  1082.     MOVE    (PS),D0            ; get the rel.addr
  1083.     LEA    0(BP,D0.W),A0        ; get the abs.addr
  1084.     @0:    CMPI.B    #$20,-1(A0,D1.W)    ; BEGIN  is char at addr+count $20
  1085.     DBNE    D1,@0            ; NOT UNTIL
  1086.     MOVE    D1,-(PS)        ; put new count on stack
  1087.     RTS
  1088.     
  1089.     DC.B    64+2,'1+',0        ; "1+" ( n -- n+1 )
  1090.     DC.W    dtrail-theLink
  1091. OnePl:    ADDQ    #1,(PS)
  1092.     RTS
  1093.  
  1094.     DC.B    64+2,'1-',0        ; "1-" ( n -- n-1 )
  1095.     DC.W    onepl-theLink
  1096. OneMi:    SUBQ    #1,(PS)
  1097.     RTS
  1098.     
  1099.     DC.B    64+2,'2+',0        ; "2+" ( n -- n+2 )
  1100.     DC.W    onemi-theLink
  1101. TwoPl:    ADDQ    #2,(PS)
  1102.     RTS
  1103.     
  1104.     DC.B    64+2,'2*',0        ; "2*" ( n -- n*2 )
  1105.     DC.W    twopl-theLink
  1106. ToStar:    ASL    (PS)
  1107.     RTS
  1108.  
  1109.     DC.B    64+2,'2/',0        ; "2/" ( n -- n/2 )
  1110.     DC.W    tostar-theLink
  1111. ToDiv:    ASR    (PS)
  1112.     RTS
  1113.     
  1114.     DC.B    5,'DEP'            ; "depth" ( -- n )
  1115.     DC.W    ToDiv-theLink        ; 16 bit entries on stack before this
  1116. depth:    move.l    szero-base(bp),d0
  1117.     sub.l    ps,d0
  1118.     move    d0,-(ps)
  1119.     bra.s    todiv
  1120.  
  1121.     DC.B    1,'@',0,0        ; "@" (at) ( addr16 -- n16 )
  1122.     DC.W    depth-theLink
  1123. At:    MOVE    (PS),D0            ; DANGER: odd values crash this
  1124.     MOVE    0(BP,D0.W),(PS)    
  1125.     RTS
  1126.  
  1127.     DC.B    1,'!',0,0        ; "!" (store) ( n16 addr16 -- )
  1128.     DC.W    at-theLink
  1129. Store:    MOVE    (PS)+,D0        ; DANGER: odd values crash this
  1130.     MOVE    (PS)+,0(BP,D0.W)
  1131.     RTS
  1132.  
  1133.     DC.B    2,'C!',0        ; "c!" (sea-store)( n8 addr16 -- )
  1134.     DC.W    store-theLink
  1135. CStore:    MOVE    (PS)+,D0        ; get the rel.addr (odd OK)
  1136.     ADDQ.L    #1,PS            ; align the stack
  1137.     MOVE.B    (PS)+,0(BP,D0.W)    ; put data at the addr
  1138.     RTS
  1139.  
  1140.     DC.B    2,'C@',0        ; "c@" (sea-at) ( addr16 -- n8 )
  1141.     DC.W    cstore-theLink
  1142. CAt:    MOVE    (PS),D0            ; get rel.addr (odd OK)
  1143.     CLR    (PS)            ; clear the result
  1144.     MOVE.B    0(BP,D0.W),1(PS)    ; stash the second byte
  1145.     RTS
  1146.  
  1147.     DC.B    64+2,'L@',0        ; "l@" (el-at) ( daddr32 -- n16 )
  1148.     DC.W    cat-theLink
  1149. LAt:    MOVEA.L    (PS)+,A0        ; get the double number "real" addr
  1150.     MOVE    (A0),-(PS)        ; fetch the contents
  1151.     RTS
  1152.  
  1153.     DC.B    64+2,'L!',0        ; "l!" (el-store)( n16 daddr32 -- )
  1154.     DC.W    lat-theLink
  1155. LStore:    MOVEA.L    (PS)+,A0
  1156.     MOVE    (PS)+,(A0)
  1157.     RTS
  1158.     
  1159.     DC.B    64+3,'DL@'        ; "dl@" ( daddr32 -- d32 )
  1160.     DC.W    lstore-theLink
  1161. DLAt:    MOVEA.L    (PS),A0
  1162.     MOVE.L    (A0),(PS)
  1163.     RTS
  1164.     
  1165.     DC.B    64+3,'DL!'        ; "dl!" ( d32 daddr32 -- )
  1166.     DC.W    dlat-theLink
  1167. DLStor:    MOVE.L    (PS)+,A0
  1168.     MOVE.L    (PS)+,(A0)
  1169.     RTS
  1170.  
  1171.     DC.B    2,'+!',0        ; "+!" ( n16 addr16 -- )
  1172.     DC.W    DLStor-theLink
  1173. pstore:    MOVE    (PS)+,D0
  1174.     MOVE    (PS)+,D1
  1175.     ADD    D1,0(BP,D0.W)
  1176.     RTS
  1177.     
  1178.     DC.B    64+4,'CBL'        ; "cblk" ( -- addr ) of fint
  1179.     DC.W    pstore-theLink
  1180. cBLK:    MOVE    #fint-base,-(PS)
  1181.     RTS
  1182.     
  1183.     DC.B    64+6,'CST'        ; "cstate" ( -- addr ) of fcolon
  1184.     DC.W    cblk-theLink
  1185. cState:    MOVE    #fcolon-base,-(PS)
  1186.     RTS
  1187.  
  1188.     DC.B    64+4,'BAS'        ; "base" ( -- addr )
  1189.     DC.W    cstate-theLink        ;   variable for the numeric radix
  1190. BaseA:    MOVE    #nbase-base,-(PS)
  1191.     RTS
  1192.  
  1193.     DC.B    64+3,'TIB'        ; "tib" ( -- addr )
  1194.     DC.W    basea-theLink        ;   variable for Terminal Input Buf.
  1195. TIB:    MOVE    #termbuf-base,-(PS)
  1196.     RTS
  1197.  
  1198.     DC.B    64+6,'LAT'        ; "latest" ( -- addr )
  1199.     DC.W    tib-theLink        ;   variable for the last dict word
  1200. Latest:    MOVE    Dict,-(PS)        ; push contents of the dict register
  1201.     RTS
  1202.  
  1203.     DC.B    64+3,'R0@'        ; "r0@" ( -- dabs.addr )
  1204.     DC.W    latest-theLink        ;   dabs.addr of r0
  1205. R0at:    MOVE.L    rzero-base(BP),-(PS)
  1206.     RTS
  1207.  
  1208.     DC.B    64+3,'RP@'        ; "rp@" ( -- dabs.addr )
  1209.     DC.W    r0at-theLink        ;   current addr of the return stack
  1210. RPat:    MOVE.L    RS,-(PS)
  1211.     RTS
  1212.  
  1213.     DC.B    64+3,'S0@'        ; "s0@" ( -- dabs.addr )
  1214.     DC.W    rpat-theLink        ;   dabs.addr of s0
  1215. S0at:    MOVE.L    szero-base(BP),-(PS)
  1216.     RTS
  1217.  
  1218.     DC.B    64+3,'SP@'        ; "sp@" ( -- dabs.addr )
  1219.     DC.W    s0at-theLink        ; address of the current stack cell
  1220. SPat:    MOVE.L    PS,-(PS)
  1221.     RTS
  1222.  
  1223.     DC.B    3,'HEX'            ; "hex" ( -- )
  1224.     DC.W    spat-theLink
  1225. hex:    MOVE    #$10,nbase-base(BP)
  1226.     RTS
  1227.  
  1228.     DC.B    7,'DEC'            ; "decimal" ( -- )
  1229.     DC.W    hex-theLink
  1230. decimal    MOVE    #10,nbase-base(BP)
  1231.     RTS
  1232.     
  1233.     DC.B    4,'?DU'            ; "?dup" ( n -- n n OR n [if n=0] )
  1234.     DC.W    decimal-theLink
  1235. qdup:    TST    (PS)
  1236.     BNE.S    dup
  1237.     RTS
  1238.  
  1239.     DC.B    64+3,'DUP'        ; "dup" ( n -- n n )
  1240.     DC.W    qdup-thelink
  1241. dup:    MOVE    (PS),-(PS)
  1242.     RTS
  1243.  
  1244.     DC.B    64+4,'OVE'        ; "over" ( n1 n2 -- n1 n2 n1 )
  1245.     DC.W    dup-theLink
  1246. over:    MOVE    2(PS),-(PS)
  1247.     RTS
  1248.  
  1249.     DC.B    3,'ROT'            ; "rot" ( n1 n2 n3 -- n2 n3 n1 )
  1250.     DC.W    over-theLink
  1251. rote:    MOVE.L    (PS)+,D0
  1252.     MOVE    (PS)+,D1
  1253.     MOVE.L    D0,-(PS)
  1254.     MOVE    D1,-(PS)
  1255.     RTS
  1256.  
  1257.     DC.B    64+4,'2DU'        ; "2dup" ( n1 n2 -- n1 n2 n1 n2 )
  1258.     DC.W    rote-theLink
  1259. todup:    MOVE.L    (PS),-(PS)
  1260.     RTS
  1261.  
  1262.     DC.B    5,'2SW'            ; "2swap"
  1263.     DC.W    todup-theLink        ;  ( n1 n2 n3 n4 -- n3 n4 n1 n2 )
  1264. toswap:    MOVE.L    (PS)+,D0
  1265.     MOVE.L    (PS)+,D1
  1266.     MOVE.L    D0,-(PS)
  1267.     MOVE.L    D1,-(PS)
  1268.     RTS
  1269.     
  1270.     DC.B    64+2,'>R',0        ; ">r" ( n -- ) rstack: ( -- n16 )
  1271.     DC.W    toswap-theLink
  1272. toR:    MOVE    (PS)+,-(RS)
  1273.     RTS
  1274.  
  1275.     DC.B    64+2,'R>',0        ; "r>" ( -- n ) rstack: ( n16 -- )
  1276.     DC.W    tor-theLink
  1277. Rfrom:    MOVE    (RS)+,-(PS)
  1278.     RTS
  1279.  
  1280.     DC.B    64+1,'R',0,0        ; "r" ( -- n ) rs: ( n16 -- n16 )
  1281.     DC.W    rfrom-theLink
  1282. Are:    MOVE    (RS),-(PS)
  1283.     RTS
  1284.  
  1285.     DC.B    4,'EXI'            ; "exit" ( -- ) drops return address
  1286.     DC.W    are-theLink
  1287. Exit:    ADDQ.L    #4,RS
  1288.     RTS
  1289.     
  1290.     DC.B    1,'*',0,0        ; "*" ( n1 n2 -- n1*n2 )
  1291.     DC.W    exit-theLink
  1292. times:    MOVE    (PS)+,D0
  1293.     MULS    (PS)+,D0
  1294.     MOVE    D0,-(PS)
  1295.     RTS
  1296.  
  1297.     DC.B    4,'/MO'            ; "/mod ( n1 n2 -- rem quot )
  1298.     DC.W    times-theLink
  1299. Smod:    MOVE    (PS)+,D0
  1300.     BNE.S    @0
  1301.     BRA.S    sfail
  1302.     @0:    MOVE    (PS)+,D1
  1303.     EXT.L    D1
  1304.     DIVS    D0,D1
  1305.     SWAP    D1
  1306.     MOVE.L    D1,-(PS)
  1307.     RTS
  1308.  
  1309.     DC.B    1,'/',0,0        ; "/" ( n1 n2 -- quotient )
  1310.     DC.W    smod-theLink
  1311. Slash:    bsr.s    smod
  1312.     JSR    swapp-base(BP)
  1313.     ADDQ.L    #2,PS
  1314.     RTS
  1315.  
  1316.     DC.B    3,'MOD'            ; "mod"    ( n1 n2 -- remainder )
  1317.     DC.W    slash-theLink
  1318. mod:    bsr.s    smod
  1319.     ADDQ.L    #2,PS
  1320.     RTS
  1321.  
  1322.     DC.B    2,'*/',0        ; "*/" ( n1 n2 n3 -- n1*n2/n3 )
  1323.     DC.W    mod-theLink
  1324. SSlash:    MOVE    (PS)+,D1
  1325.     BNE.S    sok
  1326.     ADDQ.L    #2,PS
  1327.  sfail:    MOVE    #-1,(PS)
  1328.     RTS
  1329.    sok:    MOVE    (PS)+,D0
  1330.     MULS    (PS),D0
  1331.     DIVS    D1,D0
  1332.     MOVE    D0,(PS)
  1333.     RTS
  1334.  
  1335.     DC.B    2,'U*',0        ; "u*" ( n1 n2 -- d32 )
  1336.     DC.W    sslash-theLink
  1337. UStar:    MOVE    (PS)+,D0
  1338.     MULU    (PS)+,D0
  1339.     MOVE.L    D0,-(PS)
  1340.     RTS
  1341.     
  1342.     DC.B    5,'M/M'            ; "m/mod" from King&Knight
  1343.     DC.W    ustar-theLink        ; ( num32 denom16 -- rem16 quot32 )
  1344. MSMod:    TST    (PS)            ; test for div by zero
  1345.     BNE.S    @0
  1346.     ADDQ.L    #4,PS
  1347.     BRA.S    sfail
  1348.     @0:    MOVE.L    D2,-(SP)        ; save D2
  1349.     MOVEQ    #0,D2            ; clear it
  1350.     MOVE    (PS)+,D2        ; pop denom into D2.W
  1351.     MOVE.L    (PS)+,D1        ; pop num into D1.L
  1352.     MOVE    D1,-(SP)        ; hold num.l on rstack
  1353.     CLR    D1
  1354.     SWAP    D1
  1355.     DIVU    D2,D1
  1356.     MOVE    D1,D0
  1357.     MOVE    (SP)+,D1
  1358.     DIVU    D2,D1
  1359.     SWAP    D1
  1360.     MOVE    D1,-(PS)        ; push remainder
  1361.     MOVE    D0,D1
  1362.     SWAP    D1
  1363.     MOVE.L    D1,-(PS)        ; push quotient
  1364.     MOVE.L    (SP)+,D2        ; restore register
  1365.     RTS
  1366.     
  1367.     DC.B    64+7,'DNE'        ; "dnegate" ( d32 -- -d32 )
  1368.     DC.W    msmod-theLink
  1369. DNeg:    NEG.L    (PS)
  1370.     RTS
  1371.     
  1372.     DC.B    64+2,'D+',0        ; "d+" ( d1 d2 -- d1+d2 )
  1373.     DC.W    dneg-theLink
  1374. DPlus:    MOVE.L    (PS)+,D0
  1375.     ADD.L    D0,(PS)
  1376.     RTS
  1377.     
  1378.     DC.B    128+2,'IF',0        ; "if" ( flag -- ) at runtime
  1379.     DC.W    dplus-theLink        ;      ( -- addr ) at compile time
  1380. pIf:    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1381.   pi1:    bsr.s    pbegin
  1382.     ADDQ.L    #2,DP            ; make room for offset
  1383.     RTS
  1384.     
  1385.     DC.B    128+5,'WHI'        ; "while" ( flag -- ) at runtime
  1386.     DC.W    pif-theLink        ;    ( -- addr ) at compile time
  1387. pWhile:    BRA.S    pIf
  1388.     
  1389.     DC.B    128+4,'ELS'        ; "else" ( -- ) at runtime
  1390.     DC.W    pwhile-theLink        ; ( addr -- addr ) at compile time
  1391. pElse:    MOVE    #$6000,(DP)+
  1392.     bsr.s    pi1
  1393.     JSR    swapp-base(BP)
  1394.     BRA.S    pthen
  1395.  
  1396.     DC.B    128+4,'THE'        ; "then" ( -- ) at runtime
  1397.     DC.W    pelse-theLink        ;   ( addr -- ) at compile time
  1398. pThen:    bsr.s    pbegin
  1399.     MOVE    2(PS),-(PS)        ; over
  1400.     JSR    minus-base(BP)
  1401.     JSR    swapp-base(BP)
  1402.     JMP    store-base(BP)
  1403.  
  1404.     DC.B    128+6,'REP'        ; "repeat" ( -- ) at runtime
  1405.     DC.W    pthen-theLink        ; ( b.addr w.addr -- ) at c.time
  1406. pRepet:    MOVE    #$6000,(DP)+        ; compile bra ...
  1407.     JSR    swapp-base(BP)
  1408.     BSR.S    back
  1409.     BRA.S    pThen            ; HERE OVER - SWAP ! ;
  1410.  
  1411.     DC.B    128+5,'BEG'        ; "begin" ( -- ) at runtime
  1412.     DC.W    prepet-theLink        ;    ( -- addr ) at compile time
  1413. pBegin:    JMP    here-base(BP)
  1414.  
  1415.     DC.B    128+5,'UNT'        ; "until" ( flag -- ) at runtime
  1416.     DC.W    pbegin-theLink        ;      ( addr -- ) at compile time
  1417. pUntil    MOVE.L    #$4A5E6700,(DP)+    ; compile tst (ps)+  beq ...
  1418.     BRA.S    back
  1419.     
  1420.     DC.B    128+5,'AGA'        ; "again" ( -- ) at runtime
  1421.     DC.W    puntil-theLink        ;    ( addr -- ) at compile time
  1422. pAgain:    MOVE    #$6000,(DP)+        ; compile bra ...
  1423.     BRA.S    back
  1424.  
  1425.     DC.B    4,'BAC'            ; "back" ( addr -- )
  1426.     DC.W    pagain-theLink        ;  compile negative displacement
  1427. back:    bsr.s    pbegin
  1428.     JSR    minus-base(BP)
  1429.     MOVE    (PS),D0            ; get the target addr into d0
  1430.     BGE.S    @0
  1431.     NEG    D0            ; make it positive
  1432.     @0:    ANDI    #$FF80,D0        ; if > 1 byte
  1433.     BEQ.S    @1
  1434.     JMP    comma-base(BP)        ; then comma it as a long branch
  1435.     @1:    MOVE.B    1(PS),-1(DP)        ; else make it a short branch
  1436.     JMP    drop-base(BP)
  1437.  
  1438.     DC.B    128+2,'DO',0        ; "do" ( -- addr ) at compile time
  1439.     DC.W    back-theLink        ;  ( limit index -- ) at runtime
  1440. do:    MOVE    #$2F1E,(DP)+        ; • move.l (ps)+,-(ps)
  1441.     bra.s    pbegin
  1442.     
  1443.     DC.B    128+4,'LOO'        ; "loop" ( -- ) at runtime
  1444.     DC.W    do-theLink        ;   ( addr -- ) at compile time
  1445. Loop:    MOVE.L    #$52573017,(DP)+    ;  • addq #1,(rs)  (increment ix)
  1446.     MOVE.L    #$B06F0002,(DP)+    ;  • move (rs),d0  (get ix)
  1447.     MOVE    #$6B00,(DP)+        ;  • cmp  2(rs),d0 (check lim)
  1448.   pl:    BSR.S    back            ;  • bmi  ...      (loop if ix<lim)
  1449.     MOVE    #$588F,(DP)+        ; comma in the displacement to 'do'
  1450.     RTS                ;  • addq.l #4,rs    (drop ix&lim)
  1451.     
  1452.     DC.B    128+5,'+LO'        ; "+loop" ( n -- ) at runtime
  1453.     DC.W    loop-theLink        ;   ( addr -- ) at compile time
  1454. pLoop:    MOVE    #$4EAB,(DP)+
  1455.     MOVE    #ppl-base,(DP)+        ;  • jsr ppl-base(bp)
  1456.     MOVE    #$6B00,(DP)+        ;  • bmi  ...  (neg flag change or zero)
  1457.     BRA.S    pl
  1458.  
  1459. ppl:    MOVE    (PS)+,D1        ; pop increment to d1
  1460.     ADD    D1,4(A7)        ; add increment to index
  1461.     MOVE    4(A7),D0        ; move new index to d0
  1462.     TST    D1            ; if increment is negative
  1463.     BLT.S    @0            ; then branch ahead
  1464.     CMP    6(A7),D0        ; index-limit
  1465.     RTS
  1466.  
  1467.     @0:    SUB    D1,D0            ; reinstate original index
  1468.     MOVE    6(A7),D1        ; move limit to d1
  1469.     CMP    D0,D1            ; limit-index
  1470.     RTS
  1471.     
  1472.     DC.B    5,'LEA'            ; "leave" ( -- )
  1473.     DC.W    ploop-theLink        ;  set the index to the limit
  1474. Leave:    MOVE    6(RS),4(RS)
  1475.     RTS
  1476.  
  1477.     DC.B    2,'0<',0        ; "0<" ( n -- flag )
  1478.     DC.W    leave-theLink
  1479. ZeroLT:    TST    (PS)
  1480.     BLT.S    true
  1481.  false:    CLR    (PS)
  1482.     RTS
  1483.  true:    MOVE    #-1,(PS)
  1484.     RTS
  1485.  
  1486.     DC.B    2,'0>',0        ; "0>" ( n -- flag )
  1487.     DC.W    zerolt-theLink
  1488. ZeroGT:    NEG    (PS)
  1489.     BRA.S    zerolt
  1490.  
  1491.     DC.B    2,'0=',0        ; "0=" ( n -- flag )
  1492.     DC.W    zerogt-theLink
  1493. ZeroEQ:    TST    (PS)
  1494.     BEQ.S    true
  1495.     BRA.S    false
  1496.  
  1497.     DC.B    64+1,'+',0,0        ; "+" ( n1 n2 -- n1+n2 )
  1498.     DC.W    zeroeq-theLink
  1499. plus:    MOVE    (PS)+,D0
  1500.     ADD    D0,(PS)
  1501.     RTS
  1502.  
  1503.     DC.B    1,'-',0,0        ; "-" ( n1 n2 -- n1-n2 )
  1504.     DC.W    plus-theLink
  1505. minus:    NEG    (PS)
  1506.     bra.s    plus
  1507.  
  1508.     DC.B    1,'=',0,0        ; "=" ( n1 n2 -- flag )
  1509.     DC.W    minus-theLink
  1510. equal:    bsr.s    minus
  1511.     BRA.S    zeroeq
  1512.  
  1513.     DC.B    1,'<',0,0        ; "<" ( n1 n2 -- flag )
  1514.     DC.W    equal-theLink
  1515. lesst:    bsr.s    minus
  1516.     BRA.S    zerolt
  1517.  
  1518.     DC.B    1,'>',0,0        ; ">" ( n1 n2 -- flag )
  1519.     DC.W    lesst-theLink
  1520. moret:    bsr.s    minus
  1521.     BRA.S    zerogt
  1522.  
  1523.     DC.B    64+3,'AND'        ; "and"    ( n1 n2 -- n1(and)n2 )
  1524.     DC.W    moret-theLink
  1525. andd:    MOVE    (PS)+,D0
  1526.     AND    D0,(PS)
  1527.     RTS
  1528.  
  1529.     DC.B    64+2,'OR',0        ; "or" ( n1 n2 -- n1(or)n2 )
  1530.     DC.W    andd-theLink
  1531. orr:    MOVE    (PS)+,D0
  1532.     OR    D0,(PS)
  1533.     RTS
  1534.     
  1535.     DC.B    64+3,'XOR'        ; "xor" ( n1 n2 -- n1(xor)n2 )
  1536.     DC.W    orr-theLink
  1537. xor:    MOVE    (PS)+,D0
  1538.     EOR    D0,(PS)
  1539.     RTS
  1540.  
  1541.     DC.B    3,'ABS'            ; "abs"    ( n1 -- abs(n1) )
  1542.     DC.W    xor-theLink
  1543. abs:    TST    (PS)
  1544.     BGE.S    @0
  1545.     NEG    (PS)
  1546.     @0:    RTS
  1547.  
  1548.         DC.B    3,'MIN'            ; "min" ( n1 n2 -- n(min) )
  1549.     DC.W    abs-theLink
  1550. min:    MOVE    (PS)+,D0
  1551.     CMP    (PS),D0
  1552.     BLT.S    pd0
  1553.     RTS
  1554.    pd0:    MOVE    D0,(PS)
  1555.     RTS
  1556.  
  1557.         DC.B    3,'MAX'            ; "max" ( n1 n2 -- n(max) )
  1558.     DC.W    min-theLink
  1559. max:    MOVE    (PS)+,D0
  1560.     CMP    (PS),D0
  1561.     BGE.S    pd0
  1562.     RTS
  1563.  
  1564.     DC.B    2,'2@',0        ; "2@" ( addr -- d )
  1565.     DC.W    max-theLink        ; 32 bit fetch
  1566. TwoAt:    MOVE    (PS)+,D0
  1567.     MOVE.L    0(BP,D0.W),-(PS)
  1568.     RTS
  1569.  
  1570.     DC.B    2,'2!',0        ; "2!" ( d addr -- )
  1571.     DC.W    twoat-theLink        ; 32 bit store
  1572. TwoStore:
  1573.     MOVE    (PS)+,D0
  1574.     MOVE.L    (PS)+,0(BP,D0.W)
  1575.     RTS
  1576.  
  1577.     DC.B    9,'2CO'            ; "2constant"
  1578.     DC.W    twostore-theLink    ; defining: ( d -- )
  1579. TwoCon:    JSR    token-base(BP)        ; executing: ( -- d )
  1580.     JSR    header-base(BP)
  1581.     JSR    dlit-base(BP)
  1582.     MOVE    #$4E75,(DP)+
  1583.     RTS
  1584.  
  1585.     DC.B    9,'2VA'            ; "2variable"
  1586.     DC.W    twocon-theLink        ; defining: ( -- )
  1587. TwoVar:    JSR    variable-base(BP)    ; executing: ( -- addr )
  1588.     ADDQ.L    #2,DP
  1589.     RTS
  1590.  
  1591.     DC.B    64+3,'2>R'        ; "2>r" ( d -- ) rstack: ( -- d )
  1592.     DC.W    twovar-theLink
  1593. TwoToR:    MOVE.L    (PS)+,-(RS)
  1594.     RTS
  1595.  
  1596.     DC.B    64+3,'2R>'        ; "2r>" ( -- d ) rstack: ( d -- )
  1597.     DC.W    twotor-theLink
  1598. TwoRFrom:
  1599.     MOVE.L    (RS)+,-(PS)
  1600.     RTS
  1601.     
  1602.     DC.B    3,'A>R'            ; "a>r" ( addr -- )
  1603.     DC.W    tworfrom-theLink    ;   rstack: ( -- dabs.addr )
  1604. AToR:    JSR    toabs-base(BP)
  1605.     MOVE.L    (SP)+,A0
  1606.     MOVE.L    (PS)+,-(SP)
  1607.     JMP    (A0)
  1608.  
  1609.     DC.B    64+5,'2OV'        ; "2over" ( d1 d2 -- d1 d2 d1 )
  1610.     DC.W    ator-theLink
  1611. TwoOver:
  1612.     MOVE.L    4(PS),-(PS)
  1613.     RTS
  1614.  
  1615.     DC.B    4,'2RO'            ; "2rot" ( d1 d2 d3 -- d2 d3 d1 )
  1616.     DC.W    twoover-theLink
  1617. TwoRot:    MOVE.L    (PS)+,D0
  1618.     MOVE.L    (PS)+,D1
  1619.     MOVE.L    (PS),A0
  1620.     MOVE.L    D1,(PS)
  1621.     MOVE.L    D0,-(PS)
  1622.     MOVE.L    A0,-(PS)
  1623.     RTS
  1624.  
  1625. ; floating point stack manipulation
  1626.     DC.B    64+5,'FDR'        ; FDROP ( n1 n2 n3 n4 n5 -- )
  1627.     DC.W    tworot-theLink
  1628. fdrop:    ADDQ.L    #6,PS
  1629.     ADDQ.L    #4,PS
  1630.     RTS
  1631.  
  1632.     DC.B    4,'FDU'        ; FDUP ( n5 n4 n3 n2 n1 -- n5 n4 n3 n2 n1  n5 n4 n3 n2 n1 )
  1633.     DC.W    fdrop-theLink
  1634. fdup:    LEA    10(PS),A0
  1635.     MOVE.L    -(A0),-(PS)
  1636.     MOVE.L    -(A0),-(PS)
  1637.     MOVE.W    -(A0),-(PS)
  1638.     RTS
  1639.  
  1640.     DC.B    5,'FSW'            ; FSWAP ( f1 f2 -- f2 f1 )
  1641.     DC.W    fdup-theLink
  1642. fswap:    LEA    (PS),A0
  1643.     LEA    10(PS),A1
  1644.     MOVEQ    #4,D1
  1645.     @0:    MOVE    (A1),D0
  1646.     MOVE    (A0),(A1)+
  1647.     MOVE    D0,(A0)+
  1648.     DBRA    D1,@0
  1649.     RTS
  1650.  
  1651.     DC.B    5,'FPI'            ; FPICK ( fn..f1 m|n≥m≥1 -- fn..f1 fm )
  1652.     DC.W    fswap-theLink
  1653. fpick:    MOVE    #$0A,-(PS)
  1654.     JSR    times-base(BP)
  1655.     MOVE    (PS)+,D0
  1656.     LEA    0(PS,D0.W),A0
  1657.     MOVE.L    -(A0),-(PS)
  1658.     MOVE.L    -(A0),-(PS)
  1659.     MOVE    -(A0),-(PS)
  1660.     RTS
  1661.  
  1662.     DC.B    5,'FPA'        ; FPACK ( fn..f1 fnew m -- fn..f1 ) ( fm = fnew )
  1663.     DC.W    fpick-theLink
  1664. fpack:    MOVE    #$0A,-(PS)
  1665.     JSR    times-base(BP)
  1666.     MOVE    (PS)+,D0
  1667.     LEA    0(PS,D0.W),A0
  1668.     MOVE.L    (PS)+,(A0)+
  1669.     MOVE.L    (PS)+,(A0)+
  1670.     MOVE    (PS)+,(A0)+
  1671.     RTS
  1672.  
  1673.     DC.B    5,'FRO'        ; FROLL ( fn..f1 m -- fn..fm+1 fm-1..f1 fm )
  1674.     DC.W    fpack-theLink
  1675. froll:    bsr.s    fpick
  1676.     lsr.w    #1,d0
  1677.     subq    #1,d0
  1678.     @0:    MOVE    -(A0),10(A0)
  1679.     DBRA    D0,@0
  1680.     bsr.s    fswap
  1681.     JMP    fdrop-base(BP)
  1682.  
  1683. ; float - double number conversion
  1684.     DC.B    3,'D>F'            ; D>F ( d -- n1 n2 n3 n4 n5 )
  1685.     DC.W    froll-theLink
  1686. dtof:    MOVE.L    (PS)+,(DP)
  1687.     MOVE.L    DP,-(RS)
  1688.     SUBQ.L    #6,PS
  1689.     SUBQ.L    #4,PS
  1690.     PEA    (PS)
  1691.     FL2X
  1692.     RTS
  1693.  
  1694.     DC.B    3,'F>D'            ; F>D ( n1 n2 n3 n4 n5 -- d )
  1695.     DC.W    dtof-theLink
  1696. ftod:    PEA    (PS)
  1697.     MOVE.L    DP,-(RS)
  1698.     FX2L
  1699.     JSR    fdrop-base(BP)  
  1700.     MOVE.L    (DP),-(PS)
  1701.     RTS
  1702.  
  1703.     DC.B    2,'F@',0        ; F@ ( addr -- n5 n4 n3 n2 n1 )
  1704.     DC.W    ftod-theLink
  1705. fat:    MOVE    (PS)+,D0
  1706.     LEA    10(BP,D0.W),A0
  1707.     MOVE.L    -(A0),-(PS)
  1708.     MOVE.L    -(A0),-(PS)
  1709.     MOVE    -(A0),-(PS)
  1710.     RTS
  1711.  
  1712.     DC.B    2,'F!',0        ; F! ( n5 n4 n3 n2 n1 addr -- )
  1713.     DC.W    fat-theLink
  1714. fstore:    MOVE    (PS)+,D0
  1715.     LEA    0(BP,D0.W),A0
  1716.     MOVE.L    (PS)+,(A0)+
  1717.     MOVE.L    (PS)+,(A0)+
  1718.     MOVE    (PS)+,(A0)
  1719.     RTS
  1720.  
  1721.     DC.B    2,'F,',0        ; F, ( n5 n4 n3 n2 n1 -- )
  1722.     DC.W    fstore-theLink
  1723. fcomma:    MOVE.L    (PS)+,(DP)+
  1724.     MOVE.L    (PS)+,(DP)+
  1725.     MOVE    (PS)+,(DP)+
  1726.     RTS
  1727.  
  1728.     DC.B    9,'FCO'        ; FCONSTANT ( comp: f -- ) ( run: -- f )
  1729.     DC.W    fcomma-theLink
  1730. fcon:    JSR    create-base(BP)
  1731.     BSR.S    fcomma
  1732.     JSR    does-base(BP)
  1733.     BRA.S    fat
  1734.  
  1735.     DC.B    9,'FVA'        ; FVARIABLE ( compile: -- ) ( run: -- addr )
  1736.     DC.W    fcon-theLink
  1737. fvar:    JSR    variable-base(BP)
  1738.     ADDQ.L #8,DP
  1739.     RTS
  1740.  
  1741.     DC.B    3,'SCI'            ; SCI ( decimal.places -- )
  1742.     DC.W    fvar-theLink
  1743. sci:    CLR    -(PS)
  1744.   sci1:    MOVE.L    (PS)+,form-base(BP)
  1745.     RTS
  1746.  
  1747.     DC.B    3,'FIX'            ; FIX ( decimal.places -- )
  1748.     DC.W    sci-theLink
  1749. fix:    MOVE    #$FFFF,-(PS)
  1750.     BRA.S    sci1
  1751.  
  1752.     DC.B    2,'F.',0        ; F. ( n5 n4 n3 n2 n1 -- )
  1753.     DC.W    fix-theLink
  1754. fdot:    PEA    form-base(BP)
  1755.     PEA    (PS)
  1756.     PEA    $14(DP)
  1757.     FX2DEC
  1758.     JSR    fdrop-base(BP)
  1759.     PEA    form-base(BP)
  1760.     PEA    $14(DP)
  1761.     MOVE.L    A2,-(RS)
  1762.     FDEC2STR
  1763.   dwrd:    JSR    here-base(BP)
  1764.     JSR    count-base(BP)
  1765.     JSR    type-base(BP)
  1766.     JMP    space-base(BP)
  1767.  
  1768.     DC.B    8,'FCO'        ; FCOMPARE ( f1 f2 -- f1 f2 [flag: -1|f1<f2 0|f1=f2 1|f1>f2] )
  1769.     DC.W    fdot-theLink
  1770. fcomp:    MOVE    #1,-(PS)
  1771.     PEA    2(PS)
  1772.     PEA    12(PS)
  1773.     FCMPX
  1774.     BGE.S    @0
  1775.     NEG    (PS)
  1776.     RTS
  1777.     @0:    BNE.S    @1
  1778.     CLR    (PS)
  1779.     @1:    RTS
  1780.  
  1781.     DC.B    2,'F+',0        ; F+ ( f1 f2 -- f1+f2 )
  1782.     DC.W    fcomp-theLink
  1783. fplus:    PEA    (PS)
  1784.     PEA    10(PS)
  1785.     FADDX
  1786.   fd1:    JMP    fdrop-base(BP)
  1787.  
  1788.     DC.B    2,'F-',0        ; F- ( f1 f2 -- f1-f2 )
  1789.     DC.W    fplus-theLink
  1790. fminus:    PEA    (PS)
  1791.     PEA    10(PS)
  1792.     FSUBX
  1793.     BRA.S    fd1
  1794.  
  1795.     DC.B    2,'F*',0        ; F* ( f1 f2 -- f1*f2 )
  1796.     DC.W    fminus-theLink
  1797. fstar:    PEA    (PS)
  1798.     PEA    10(PS)
  1799.     FMULX
  1800.     BRA.S    fd1
  1801.  
  1802.     DC.B    2,'F/',0        ; F/ ( f1 f2 -- f1/f2 )
  1803.     DC.W    fstar-theLink
  1804. fslash:    PEA    (PS)
  1805.     PEA    10(PS)
  1806.     FDIVX
  1807.     BRA.S    fd1
  1808.  
  1809.     DC.B    4,'FRE'            ; FREM ( f1 f2 -- rem[f1/f2] )
  1810.     DC.W    fslash-theLink
  1811. frem:    PEA    (PS)
  1812.     PEA    10(PS)
  1813.     FREMX
  1814.     BRA.S    fd1
  1815.  
  1816.     DC.B    2,'F^',0        ; F^ ( f1 f2 -- f1^f2 )
  1817.     DC.W    frem-theLink
  1818. ftothe:    PEA    (PS)
  1819.     PEA    10(PS)
  1820.     FXPWRY
  1821.     BRA.S    fd1
  1822.  
  1823.     DC.B    4,'FIN'            ; FINT ( f -- int[f] )
  1824.     DC.W    ftothe-theLink
  1825. finte:    PEA    (PS)
  1826.     FTINTX
  1827.     RTS
  1828.  
  1829.     DC.B    4,'FAB'            ; FABS ( f -- |f| )
  1830.     DC.W    finte -theLink
  1831. fabs:    PEA    (PS)
  1832.     FABSX
  1833.     RTS
  1834.  
  1835.     DC.B    5,'FSQ'            ; FSQRT ( f -- sqrt[f] )
  1836.     DC.W    fabs-theLink
  1837. fsqrt:    PEA    (PS)
  1838.     FSQRTX
  1839.     RTS
  1840.  
  1841.     DC.B    4,'FSI'            ; FSIN ( f -- sin[f] )
  1842.     DC.W    fsqrt-theLink
  1843. fsin:    PEA    (PS)
  1844.     FSINX
  1845.     RTS
  1846.  
  1847.     DC.B    4,'FCO'            ; FCOS ( f -- cos[f] )
  1848.     DC.W    fsin-theLink
  1849. fcos:    PEA    (PS)
  1850.     FCOSX
  1851.     RTS
  1852.  
  1853.     DC.B    4,'FTA'            ; FTAN ( f -- tan[f] )
  1854.     DC.W    fcos-theLink
  1855. ftan:    PEA    (PS)
  1856.     FTANX
  1857.     RTS
  1858.  
  1859.     DC.B    4,'FAT'            ; FATN ( f -- atn[f] )
  1860.     DC.W    ftan-theLink
  1861. fatn:    PEA    (PS)
  1862.     FATNX
  1863.     RTS
  1864.  
  1865.     DC.B    4,'FEX'            ; FEXP ( f1 -- e^f1 )
  1866.     DC.W    fatn-theLink
  1867. fexp:    PEA    (PS)
  1868.     FEXPX
  1869.     RTS
  1870.  
  1871.     DC.B    3,'FLN'            ; FLN ( f1 -- ln[f1] )
  1872.     DC.W    fexp-theLink
  1873. fln:    PEA    (PS)
  1874.     FLNX
  1875.     RTS
  1876.  
  1877.     DC.B    4,'@PE'            ; "@pen" ( -- h v )
  1878.     DC.W    fln-theLink
  1879. AtPen:    PEA    (DP)
  1880.     _GetPen
  1881.     MOVE.L    (DP),-(PS)
  1882.     RTS
  1883.  
  1884.     DC.B    64+4,'!PE'        ; "!pen" ( h v -- )
  1885.     DC.W    atpen-theLink
  1886. SetPen:    MOVE.L    (PS)+,-(SP)
  1887.     _MoveTo
  1888.     RTS
  1889.  
  1890.     DC.B    64+3,'-TO'        ; "-to" ( h v -- )
  1891.     DC.W    setpen-theLink
  1892. LineTo:    MOVE.L    (PS)+,-(SP)
  1893.     _LineTo
  1894.     RTS
  1895.  
  1896.     DC.B    64+5,'PMO'        ; "pmode" ( mode -- )
  1897.     DC.W    lineto-theLink
  1898. PMode:    MOVE    (PS)+,-(SP)
  1899.     _PenMode
  1900.     RTS
  1901.  
  1902.     DC.B    6,'@MO'            ; "@mouse" ( -- h v )
  1903.     DC.W    pmode-theLink
  1904. AtMouse:
  1905.     SUBQ.L    #4,PS
  1906.     PEA    (PS)
  1907.     _GetMouse
  1908.     RTS
  1909.  
  1910.     DC.B    4,'TAS'            ; "task" ( -- ) a no-op word
  1911.     DC.W    AtMouse-theLink        ;  use:  forget task : task ;
  1912. Task:    RTS                ;  to cleanup dictionary
  1913. DictEnd:
  1914.